home *** CD-ROM | disk | FTP | other *** search
/ Ham Radio 2000 #1 / Ham Radio 2000.iso / ham2000 / packet / p_aa4re / bb212src / bbbpa.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-02-16  |  20.5 KB  |  581 lines
  1. (*===========================================================================*)
  2. (* Build path array                                                          *)
  3. (*                                                                           *)
  4. (*   Copyright 1990, 1991, 1992 by H. Roy Engehausen.  All rights reserved.  *)
  5. (*                                                                           *)
  6. (*===========================================================================*)
  7.  
  8. {$O+}
  9.  
  10. {$UNDEF  DEBUG1} (* Used to debug watching BPA work *)
  11. {$UNDEF  DEBUG2}
  12. {$UNDEF  DEBUG3} (* Used to debug SORT *)
  13. {$UNDEF  DEBUG4} (* Used to debug aging *)
  14. {$UNDEF  DEBUG5} (* Used to debug size *)
  15. {$UNDEF  DEBUG6} (* Used to debug type *)
  16.  
  17. {$DEFINE POINT_CHK}
  18.  
  19. UNIT BBBPA;
  20.  
  21. INTERFACE
  22.  
  23.   USES
  24.     bbdummy,
  25.     bbfwdd;
  26.  
  27.   TYPE
  28.     bpa_route_used_type = ^msg_r_ptr;
  29.  
  30.   PROCEDURE build_path_array(path_data  : path_block_ptr;
  31.                              inc_routes : BOOLEAN);
  32.  
  33.   PROCEDURE sort_path_array(path_data : path_block_ptr);
  34.  
  35.   CONST path_block_mem_id : mem_id_str = 'BPA';
  36.   CONST path_block_lst_id : mem_id_str = 'BPL';
  37.  
  38. IMPLEMENTATION
  39.  
  40.   USES
  41.     CRT,
  42.     bbbug,
  43.     bbmem,
  44.     bbfnr,
  45.     bbmisc3,
  46.     bbstr,
  47.     bbtask,
  48.     bbtime,
  49.     bbtrace,
  50.     bbwin;
  51.  
  52. (*===========================================================================*)
  53. (* Build a path data array                                                   *)
  54. (*===========================================================================*)
  55.  
  56. PROCEDURE build_path_array(path_data    : path_block_ptr;
  57.                            inc_routes : BOOLEAN);
  58.  
  59.   VAR
  60.     b           : BOOLEAN;
  61.     bpa_route   : bpa_route_used_type;
  62.     e_mode      : BOOLEAN;
  63.     inx         : BYTE;
  64.     last_route  : msg_r_ptr;
  65.     msg_array   : msg_p_ptr;
  66.     msg_cnt     : BYTE;
  67.     route_used  : BOOLEAN;
  68.     out_array   : msg_p_ptr;
  69.     this_dblk   : msg_d_ptr;
  70.     this_route  : msg_r_ptr;
  71.     this_msg    : msg_index_ptr;
  72.  
  73.   LABEL
  74.     go_next_msg;
  75.  
  76.   FUNCTION test_number(s : str4) : BOOLEAN;
  77.     VAR
  78.       code : INTEGER;
  79.       i    : INTEGER;
  80.  
  81.     BEGIN;
  82.  
  83.       {$IFDEF DEBUG4}
  84.         WRITELN('#1=', LENGTH(s), '=', s);
  85.       {$ENDIF}
  86.  
  87.       test_number := FALSE;
  88.       IF (LENGTH(s) > 3) OR (s = '') THEN EXIT;
  89.  
  90.       VAL(s, i, code);
  91.  
  92.       {$IFDEF DEBUG4}
  93.         WRITELN('#2=', i, '=', code);
  94.       {$ENDIF}
  95.  
  96.       IF (code <> 0) OR (i < 0) THEN EXIT;
  97.       test_number := TRUE;
  98.  
  99.     END;
  100.  
  101.   BEGIN;
  102.  
  103.     {$IFDEF DEBUG1}
  104.       WRITELN('BPA look - ',
  105.                        path_data^.path_pattern, ' / ', path_data^.path_target);
  106.     {$ENDIF}
  107.  
  108.     {$IFDEF DEBUG6}
  109.       WRITELN('BPA type - ', LENGTH(path_data^.path_type_send), ' - ',
  110.                                     path_data^.path_type_send);
  111.     {$ENDIF}
  112.  
  113.     (*-----------------------------------------------------------------------*)
  114.     (* Initialize things                                                     *)
  115.     (*-----------------------------------------------------------------------*)
  116.  
  117.     msg_cnt    := 0;
  118.     last_route := NIL;
  119.     path_data^.path_route := NIL;
  120.  
  121.     (*-----------------------------------------------------------------------*)
  122.     (* Are we in emergency forward only mode?                                *)
  123.     (*-----------------------------------------------------------------------*)
  124.  
  125.     e_mode := opt_block.operate_mode.mode_fwd_emer
  126.                               AND active_port^.port_operate_mode.mode_fwd_emer;
  127.  
  128.     (*-----------------------------------------------------------------------*)
  129.     (* Free any old area;                                                    *)
  130.     (*-----------------------------------------------------------------------*)
  131.  
  132.     free_task_mem(path_block_mem_id, TRUE);
  133.     free_task_mem(path_block_lst_id, TRUE);
  134.  
  135.     (*-----------------------------------------------------------------------*)
  136.     (* Search down the route list                                            *)
  137.     (*-----------------------------------------------------------------------*)
  138.  
  139.     this_route := find_next_route(path_data, @msg_route_list);
  140.  
  141.     (*-----------------------------------------------------------------------*)
  142.     (* Get the array area                                                    *)
  143.     (*-----------------------------------------------------------------------*)
  144.  
  145.     IF this_route <> NIL THEN
  146.       msg_array := get_task_mem(path_block_mem_id, SIZEOF(msg_path_block));
  147.  
  148.     IF (this_route = NIL) OR (msg_array = NIL) THEN
  149.       BEGIN;
  150.         path_data^.path_msg_count   := 0;
  151.         path_data^.path_msg_list    := NIL;
  152.         {$IFDEF DEBUG1}
  153.           WRITELN('BPA not found');
  154.         {$ENDIF}
  155.         EXIT;
  156.       END;
  157.  
  158.     (*-----------------------------------------------------------------------*)
  159.     (* Loop while we found something                                         *)
  160.     (*-----------------------------------------------------------------------*)
  161.  
  162.     {$IFDEF DEBUG1}
  163.       WRITELN('BPA found - ',
  164.                        path_data^.path_pattern, ' / ', path_data^.path_target);
  165.     {$ENDIF}
  166.  
  167.     WHILE this_route <> NIL DO
  168.       BEGIN;
  169.  
  170.         (*-------------------------------------------------------------------*)
  171.         (* Debugging                                                         *)
  172.         (*-------------------------------------------------------------------*)
  173.  
  174.         {$IFDEF POINT_CHK}
  175.           test_pointer(this_route);
  176.         {$ENDIF}
  177.  
  178.         {$IFDEF DEBUG1}
  179.           WRITELN('BPA route found -- ', this_route^.msg_r_info);
  180.         {$ENDIF}
  181.  
  182.         (*-------------------------------------------------------------------*)
  183.         (* Assume route not used                                             *)
  184.         (*-------------------------------------------------------------------*)
  185.  
  186.         route_used := FALSE;
  187.  
  188.         (*-------------------------------------------------------------------*)
  189.         (* Search the message list looking for messages pointing at this     *)
  190.         (* route                                                             *)
  191.         (*-------------------------------------------------------------------*)
  192.  
  193.         this_msg := find_next_msg(this_route, NIL, inx);
  194.  
  195.         WHILE (this_msg <> NIL) AND (msg_cnt < msg_path_max_msgs) DO
  196.           BEGIN;
  197.  
  198.             {$IFDEF POINT_CHK}
  199.               test_pointer(this_msg);
  200.             {$ENDIF}
  201.  
  202.             {$IFDEF DEBUG1}
  203.               WRITELN('BPA msg found -- ', this_msg^.msg_i_mb.msg_number);
  204.             {$ENDIF}
  205.  
  206.             (*---------------------------------------------------------------*)
  207.             (* See if we can forward this message type                       *)
  208.             (*---------------------------------------------------------------*)
  209.  
  210.             b := (NOT e_mode) OR (this_msg^.msg_i_mb.msg_type >= mt_nts);
  211.  
  212.             IF b AND (path_data^.path_type_send <> '') THEN
  213.               b := POS(this_msg^.msg_i_mb.msg_type,
  214.                                                 path_data^.path_type_send) > 0;
  215.  
  216.             IF NOT b THEN
  217.               BEGIN;
  218.                 path_data^.path_type_rej := TRUE;
  219.                 GOTO go_next_msg;
  220.               END;
  221.  
  222.             (*---------------------------------------------------------------*)
  223.             (* See if size is ok                                             *)
  224.             (*---------------------------------------------------------------*)
  225.  
  226.             IF this_msg^.msg_i_mb.msg_size > path_data^.path_size THEN
  227.               BEGIN;
  228.                 path_data^.path_size_rej := TRUE;
  229.                 GOTO go_next_msg;
  230.               END;
  231.  
  232.             (*---------------------------------------------------------------*)
  233.             (* See if age is ok                                              *)
  234.             (*---------------------------------------------------------------*)
  235.  
  236.              IF this_msg^.msg_i_mb.msg_dt_in >= path_data^.path_age THEN
  237.               BEGIN;
  238.                 path_data^.path_date_rej := TRUE;
  239.                 GOTO go_next_msg;
  240.               END;
  241.  
  242.             (*---------------------------------------------------------------*)
  243.             (* We found one so stick it in the array                         *)
  244.             (*---------------------------------------------------------------*)
  245.  
  246.             INC(msg_cnt);
  247.  
  248.             msg_array^[msg_cnt].msg_p_i    := this_msg;
  249.             msg_array^[msg_cnt].msg_p_item := inx;
  250.  
  251.             (*---------------------------------------------------------------*)
  252.             (* Come here to skip this message                                *)
  253.             (*---------------------------------------------------------------*)
  254.  
  255. go_next_msg:
  256.  
  257.             (*---------------------------------------------------------------*)
  258.             (* Show route was used                                           *)
  259.             (*---------------------------------------------------------------*)
  260.  
  261.             route_used := TRUE;
  262.  
  263.             (*---------------------------------------------------------------*)
  264.             (* Find next message                                             *)
  265.             (*---------------------------------------------------------------*)
  266.  
  267.             this_msg := find_next_msg(this_route, this_msg, inx);
  268.  
  269.           END; (*----- End loop thru all messages ---------------------------*)
  270.  
  271.         (*-------------------------------------------------------------------*)
  272.         (* Bump route # used if necessary                                    *)
  273.         (*-------------------------------------------------------------------*)
  274.  
  275.         IF inc_routes AND route_used THEN
  276.           REPEAT
  277.             INC(this_route^.msg_r_nroute);
  278.           UNTIL NOT test_number(subword(@this_route^.msg_r_info,
  279.                                                  this_route^.msg_r_nroute, 1));
  280.  
  281.         (*-------------------------------------------------------------------*)
  282.         (* See if route was used.                                            *)
  283.         (*-------------------------------------------------------------------*)
  284.  
  285.         IF route_used THEN
  286.           BEGIN;
  287.  
  288.             (*---------------------------------------------------------------*)
  289.             (* Route used so save the info                                   *)
  290.             (*---------------------------------------------------------------*)
  291.  
  292.             bpa_route := get_task_mem(path_block_lst_id,
  293.                                                  SIZEOF(bpa_route_used_type));
  294.  
  295.             {$IFDEF POINT_CHK}
  296.               test_pointer(bpa_route);
  297.             {$ENDIF}
  298.  
  299.             bpa_route^ := this_route;
  300.  
  301.             path_data^.path_r_nochange := FALSE;
  302.  
  303.           END;
  304.  
  305.         (*-------------------------------------------------------------------*)
  306.         (* Go to next route                                                  *)
  307.         (*-------------------------------------------------------------------*)
  308.  
  309.         this_route := find_next_route(path_data, this_route);
  310.  
  311.       END; (*---- End loop thru all routes ----------------------------------*)
  312.  
  313.     (*-----------------------------------------------------------------------*)
  314.     (* Reduce debugging pain                                                 *)
  315.     (*-----------------------------------------------------------------------*)
  316.  
  317.     {$IFDEF POINT_CHK}
  318.       task_switch;
  319.     {$ENDIF}
  320.  
  321.     (*-----------------------------------------------------------------------*)
  322.     (* Set the pointers to the output.  Free unused part of array.  If       *)
  323.     (* no messages, free the whole shebang                                   *)
  324.     (*-----------------------------------------------------------------------*)
  325.  
  326.     path_data^.path_msg_count  := msg_cnt;
  327.  
  328.     IF msg_cnt = 0 THEN
  329.       BEGIN
  330.  
  331.         path_data^.path_msg_list := NIL;
  332.         free_task_mem(path_block_mem_id, TRUE);
  333.  
  334.       END
  335.     ELSE
  336.       BEGIN;
  337.  
  338.         path_data^.path_msg_list := msg_array;
  339.  
  340.         msg_cnt := msg_path_max_msgs - msg_cnt;
  341.  
  342.         IF msg_cnt > 0 THEN
  343.           free_task_mem_end(path_block_mem_id,
  344.                                   WORD(msg_cnt) * SIZEOF(msg_path_array_item));
  345.  
  346.       END;
  347.  
  348.     {$IFDEF DEBUG2}
  349.       WRITELN('BPA done -- ', path_data^.path_msg_count,
  350.                     ' -- ', p2x(path_data^.path_msg_list));
  351.     {$ENDIF}
  352.  
  353.   END;
  354.  
  355. (*===========================================================================*)
  356. (* Sort a path data array                                                    *)
  357. (*===========================================================================*)
  358.  
  359. PROCEDURE sort_path_array(path_data : path_block_ptr);
  360.  
  361.   VAR
  362.     inx       : BYTE;
  363.     msg_cnt   : BYTE;
  364.     msg_array : msg_p_ptr;
  365.     sort_type : CHAR;
  366.  
  367.   (*=========================================================================*)
  368.   (* Procedure to do one sort                                                *)
  369.   (*=========================================================================*)
  370.  
  371.   PROCEDURE sort_bpa(sort_type : CHAR; msg_array : msg_p_ptr);
  372.  
  373.     VAR
  374.       show_err  : BOOLEAN;
  375.       need_pass : BOOLEAN;
  376.       p1        : msg_path_array_item;
  377.       p2        : msg_path_array_item;
  378.       sort_inx  : BYTE;
  379.       sort_max  : BYTE;
  380.  
  381.       {$IFDEF DEBUG3}
  382.         s1 : STRING;
  383.         s2 : STRING[5];
  384.       {$ENDIF}
  385.  
  386.     (*=======================================================================*)
  387.     (* Compare two items.  If compare is TRUE then they are out of order     *)
  388.     (*=======================================================================*)
  389.  
  390.     FUNCTION sort_compare(m1, m2 : msg_index_ptr): BOOLEAN;
  391.  
  392.       VAR
  393.         d1 : LONGINT;
  394.         d2 : LONGINT;
  395.         i  : INTEGER;
  396.  
  397.       BEGIN;
  398.  
  399.         (*-------------------------------------------------------------------*)
  400.         (* Execute the correct sort                                          *)
  401.         (*-------------------------------------------------------------------*)
  402.  
  403.         CASE sort_type OF
  404.  
  405.           (*-----------------------------------------------------------------*)
  406.           (* Sort by type                                                    *)
  407.           (*-----------------------------------------------------------------*)
  408.  
  409.           path_sort_type:
  410.             BEGIN;
  411.               i := ORD(m1^.msg_i_mb.msg_type) - ORD(m2^.msg_i_mb.msg_type);
  412.               IF i <> 0 THEN
  413.                 sort_compare := i < 0
  414.               ELSE
  415.                 sort_compare := (m1^.msg_i_mb.msg_flag AND mf_fwd_list) >
  416.                                        (m2^.msg_i_mb.msg_flag AND mf_fwd_list);
  417.             END;
  418.  
  419.           (*-----------------------------------------------------------------*)
  420.           (* Sort by age                                                     *)
  421.           (*-----------------------------------------------------------------*)
  422.  
  423.           path_sort_age:
  424.             sort_compare := m1^.msg_i_mb.msg_dt_in > m2^.msg_i_mb.msg_dt_in;
  425.  
  426.           (*-----------------------------------------------------------------*)
  427.           (* Sort by size                                                    *)
  428.           (*-----------------------------------------------------------------*)
  429.  
  430.           path_sort_size:
  431.             sort_compare := m1^.msg_i_mb.msg_size  > m2^.msg_i_mb.msg_size;
  432.  
  433.           (*-----------------------------------------------------------------*)
  434.           (* Sort by date (Time doesnt' count)                               *)
  435.           (*-----------------------------------------------------------------*)
  436.  
  437.           path_sort_date, path_sort_rdate:
  438.             BEGIN;
  439.               d1 := m1^.msg_i_mb.msg_dt_in DIV ticks_per_day;
  440.               d2 := m2^.msg_i_mb.msg_dt_in DIV ticks_per_day;
  441.               IF sort_type = path_sort_date THEN
  442.                 sort_compare := d1 > d2
  443.               ELSE
  444.                 sort_compare := d1 < d2;
  445.             END;
  446.  
  447.           (*-----------------------------------------------------------------*)
  448.           (* Bad sort type                                                   *)
  449.           (*-----------------------------------------------------------------*)
  450.  
  451.           ELSE
  452.             BEGIN;
  453.               IF show_err THEN
  454.                 BEGIN;
  455.                   window_write_critical('FWD:Bad sort character -- ',
  456.                                                                     sort_type);
  457.                   show_err := FALSE;
  458.                 END;
  459.               sort_compare := FALSE;
  460.             END;
  461.  
  462.         END;
  463.  
  464.       END; (*----- End sort compare subroutine ------------------------------*)
  465.  
  466.     (*-----------------------------------------------------------------------*)
  467.     (* Main line of sort once                                                *)
  468.     (*-----------------------------------------------------------------------*)
  469.  
  470.     BEGIN;
  471.  
  472.       (*---------------------------------------------------------------------*)
  473.       (* Get ready to loop                                                   *)
  474.       (*---------------------------------------------------------------------*)
  475.  
  476.       show_err  := TRUE;
  477.       sort_max  := msg_cnt - 1;
  478.  
  479.       {$IFDEF DEBUG3}
  480.         WRITELN('Sorting ', sort_max, ' by ', sort_type);
  481.       {$ENDIF}
  482.  
  483.       (*---------------------------------------------------------------------*)
  484.       (* Keep looping until no more sorting to be done                       *)
  485.       (*---------------------------------------------------------------------*)
  486.  
  487.       REPEAT
  488.  
  489.         {$IFDEF DEBUG3}
  490.           WRITELN('Sort pass');
  491.         {$ENDIF}
  492.  
  493.         need_pass := FALSE;
  494.  
  495.         (*-------------------------------------------------------------------*)
  496.         (* Make a pass over the array to sort it                             *)
  497.         (*-------------------------------------------------------------------*)
  498.  
  499.         FOR sort_inx := 1 TO sort_max DO
  500.           BEGIN;
  501.  
  502.             p1 := msg_array^[sort_inx];
  503.             p2 := msg_array^[sort_inx + 1];
  504.  
  505.             IF sort_compare(p1.msg_p_i, p2.msg_p_i) THEN
  506.               BEGIN;
  507.                 msg_array^[sort_inx]     := p2;
  508.                 msg_array^[sort_inx + 1] := p1;
  509.                 need_pass := TRUE;
  510.               END;
  511.  
  512.           END;
  513.  
  514.       UNTIL NOT need_pass; (*---- End sort loop -----------------------------*)
  515.  
  516.       (*---------------------------------------------------------------------*)
  517.       (* Debugging display of SORT results                                   *)
  518.       (*---------------------------------------------------------------------*)
  519.  
  520.       {$IFDEF DEBUG3}
  521.         WRITELN('Sort out');
  522.         s1 := '';
  523.         FOR sort_inx := 1 TO (sort_max + 1) DO
  524.           BEGIN;
  525.             STR(msg_array^[sort_inx].msg_p_i^.msg_i_mb.msg_number, s2);
  526.             s1 := s1 + s2;
  527.             IF LENGTH(s1) > 70 THEN
  528.               BEGIN;
  529.                 WRITELN(s1);
  530.                 s1 := '';
  531.               END
  532.             ELSE
  533.               s1 := s1 + ', ';
  534.           END;
  535.         IF LENGTH(s1) > 0 THEN
  536.           WRITELN(s1);
  537.  
  538.         WRITELN('Sort out');
  539.         DELAY(3000);
  540.       {$ENDIF}
  541.  
  542.     END; (*----- End actual sort subroutine ---------------------------------*)
  543.  
  544.   (*-------------------------------------------------------------------------*)
  545.   (* Main line of sort path array                                            *)
  546.   (*-------------------------------------------------------------------------*)
  547.  
  548.   BEGIN;
  549.  
  550.     (*-----------------------------------------------------------------------*)
  551.     (* Initialize things.  Leave if nothing to do                            *)
  552.     (*-----------------------------------------------------------------------*)
  553.  
  554.     msg_cnt   := path_data^.path_msg_count;
  555.  
  556.     IF (msg_cnt < 2) THEN
  557.       EXIT;
  558.  
  559.     msg_array := path_data^.path_msg_list;
  560.  
  561.     (*-----------------------------------------------------------------------*)
  562.     (* Sort the array                                                        *)
  563.     (*-----------------------------------------------------------------------*)
  564.  
  565.     FOR inx := SIZEOF(path_data^.path_sort) DOWNTO 1 DO
  566.       BEGIN;
  567.         sort_type := path_data^.path_sort[inx];
  568.         {$IFDEF DEBUG3}
  569.           WRITELN('SORT TYPE = ', sort_type, ' / ', inx);
  570.         {$ENDIF}
  571.         IF sort_type <> path_sort_none THEN
  572.           BEGIN;
  573.             sort_bpa(sort_type, msg_array);
  574.             task_switch;
  575.           END;
  576.       END;
  577.  
  578.   END; (*----- End sort array -----------------------------------------------*)
  579.  
  580. END.
  581.